home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PBLIB1
/
PROGS
/
TPRINT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-05-03
|
14KB
|
399 lines
Program TPrint;
{$M 20000,0,100000 }
uses PbMISC, PbDATA, PbOBJS, PbHIGH, PbPARMS, PbTBOX, PbOUT1;
{
Description : Not so Minimalist Text file processing program
Author : Howard Richoux
Date : 1/1/91
Last revised: 1/5/94 3.00 Brought up to current standards
1/5/94 3.01 \SOURCE section
1/7/93 3.02 center/join problem
1/7/94 3.03 add @1-@9 substitution parameters
2/18/94 3.05 NEW LIBRARIES
Application : IBM PC and compatibles, done in Turbo Pascal 7.0
Status : Placed in the Public Domain by HNR Software 1/29/94
Published in: none
}
var TriggerCh : char; { '\' }
center : integer; {number of lines to center }
secttag : string[30]; {\SECTION ... for sourcing }
EchoFlag : boolean; {echo tprint commands (debugging)}
SourceFlag : boolean; {read secondlevel files or not }
DoubleFlag : boolean; {double space lines }
HeadersFlag : boolean; {turn off headers }
FootersFlag : boolean; {turn off footers }
SectLineFlag : boolean; {true when first line of sourced section}
var AtStr : array[1..9] of string;
Procedure CheckPageLimits(pFirst,pLast,pCount : integer);
begin
OUTSetPrint;
if OUTCurrentpage < pfirst then OUTSetNOPrint;
if OUTCurrentpage > pLast then OUTSetNOPrint;
end;
Procedure ReplaceAtParms(var line : string);
var i : integer;
s : string;
begin
{ writeln(line,'<--');}
for i := 1 to 9 do
begin
s := '@'+integerstr(i,1);
line := FindAndReplaceStr(line,s,AtStr[i],true,true);
end;
end;
Procedure PrintLine(line : string);
var s : string;
begin
CheckPageLimits(pFirst,pLast,pCount);
if ord(line[1]) = 12 then
begin
writeln('found FF in text currpage = ',OUTCurrentpage);
OUTdonewithpage;
exit;
end;
if center > 0 then
begin
s := centerstr(line,OUTCurrentLineLen);
dec(center);
OUT(s);
end
else begin
s := line;
if TBOXType > 0 then TBOXConvertLine(s);
OUTjoin(s);
end;
if doubleflag then OUT(' ');
end;
Procedure PrintBlankLines(n : integer);
var i : integer;
begin
if (n > 0) and (n < 100) then
for i := 1 to n do
begin
PrintLine(' ');
end;
end;
Function CommandLine(var line : string; var newfile,newsect : string) : boolean;
var ret,null : boolean;
s,s1,s2,s2u: string;
termch : char;
i : integer;
begin
ret := false;
i := Pos('@',line);
if i > 0 then ReplaceAtParms(line);
i := pos(TriggerCh,line);
if (i = 1) or (i = 2) then
begin
if EchoFlag then PrintLine('['+line+']');
s := line;
delete(s,1,i);
if (i = 2) then delete(s,length(s),1); {must be in brackets}
ret := true;
s1 := UpCaseStr(GetLeftStr(s,' '));
if length(s1) > 0 then
begin
s2 := GetLeftStr(s,' ');
s2u := UpCaseStr(s2);
if pDebug then writeln('Command [',s1,'] arg [',s2,']');
if s1 = '' then PrintBlankLines(1)
else if s1 = 'NEW' then OUTdonewithpage
else if s1 = 'INDENT' then OUTSetIndent(StrInt(s2))
else if s1 = 'SPACE' then PrintBlankLines(StrInt(s2))
else if s1 = 'CENTER' then
begin
if s2u = 'ON' then center := 9999
else if s2u = 'OFF' then center := 0
else begin
center := 1;
delete(line,1,8);
trim(line);
line := UnQT(line);
ret := false;
end;
end
else if s1 = 'HEADERS' then
begin
if s2u = '' then s2u := 'ON';
if s2u = 'ON' then
begin
headersflag := true;
if not footersflag then
OUTSetHeaders(pHeader1,pHeader2,pHeader3,'','')
else OUTSetHeaders(pHeader1,pHeader2,pHeader3,
pFooter1,pFooter2);
end
else if s2u = 'OFF' then
begin
headersflag := false;
if not footersflag then
OUTSetHeaders('','','','','')
else OUTSetHeaders('','','',pFooter1,pFooter2);
end;
end
else if s1 = 'FOOTERS' then
begin
if s2u = '' then s2u := 'ON';
if s2u = 'ON' then
begin
footersflag := true;
if not headersflag then
OUTSetHeaders('','','',pFooter1,pFooter2)
else OUTSetHeaders(pHeader1,pHeader2,pHeader3,
pFooter1,pFooter2);
end
else if s2u = 'OFF' then
begin
footersflag := false;
if not headersflag then
OUTSetHeaders('','','','','')
else OUTSetHeaders(pHeader1,pHeader2,pHeader3,'','');
end;
end
else if s1 = 'DOUBLESPACE' then
begin
if s2u = '' then s2u := 'ON';
if s2u = 'ON' then doubleflag := true
else if s2u = 'OFF' then doubleflag := false;
end
else if s1 = 'JOIN' then
begin
if s2u = 'ON' then OUTSetJoin
else if s2u = 'OFF' then OUTFlushJoin(true)
else begin
OUTSetJoinWidth(StrInt(s2));
OUTSetJoin;
end;
end
else if s1 = 'ECHO' then
begin
if s2u = '' then s2u := 'ON';
if s2u = 'ON' then EchoFlag := true
else if s2u = 'OFF' then EchoFlag := false;
end
else if s1 = 'SOURCE' then
begin
newsect := GetDelimitedStr(s2u,'(',')');
newfile := s2u;
{ OUT(' SOURCE ['+newfile+'] ['+newsect+'] ');}
end
else if s1 = 'HEADER1' then
begin
s := line; null := ReplaceStringWithToken(s,pHeader1,chr(254));
if pDebug then writeln('pHeader1 [',pHeader1,']');
OUTSetHeaders(pHeader1, pHeader2, pHeader3, pFooter1, pFooter2);
end
else if s1 = 'HEADER2' then
begin
s := line; null := ReplaceStringWithToken(s,pHeader2,chr(254));
OUTSetHeaders(pHeader1, pHeader2, pHeader3, pFooter1, pFooter2);
end
else if s1 = 'HEADER3' then
begin
s := line; null := ReplaceStringWithToken(s,pHeader3,chr(254));
OUTSetHeaders(pHeader1, pHeader2, pHeader3, pFooter1, pFooter2);
end
else if s1 = 'FOOTER1' then
begin
s := line; null := ReplaceStringWithToken(s,pFooter1,chr(254));
OUTSetHeaders(pHeader1, pHeader2, pHeader3, pFooter1, pFooter2);
end
else if s1 = 'FOOTER2' then
begin
s := line; null := ReplaceStringWithToken(s,pFooter2,chr(254));
OUTSetHeaders(pHeader1, pHeader2, pHeader3, pFooter1, pFooter2);
end
else if s1 = 'TBOXTYPE' then TBOXType := StrInt(s2)
else if s1 = 'PRINT' then OUTSetNoPrint
else if s1 = 'NOPRINT' then OUTSetPrint
else if s1 = 'QUIT' then newfile := s1
else if s1 = 'EXIT' then newfile := s1
else begin ret := false; end;
end;
end;
CommandLine := ret;
end;
Procedure ProcessSourcedLine(line : string);
var newfile,newsect : string;
begin
if SectLineFlag then
begin { skip this line for printing purposes }
SectLineFlag := false;
exit;
end;
newfile := '';
newsect := '';
if not CommandLine(line,newfile,newsect) then
begin
PrintLine(line);
end;
if newfile <> '' then PrintLine('Nesting too deep - '+newfile);
end;
Procedure ReadFile1(fname : string);
var i,linenumber : integer;
line : string;
newfile : string[40];
newsect : string[40];
done : boolean;
tx : TFILE_object;
begin
pCurrFName := fname;
OUTSetPageLabels(PackTimeStr(FileDate(pCurrFname,'')),'','');
linenumber := 0;
newfile := ''; newsect := '';
done := false;
if not fileexists(fname) then
begin
forceext(fname,'txt');
if not fileexists(fname) then
begin
forceext(fname,'doc');
if not fileexists(fname) then
begin
writeln('No file found [',pCurrFName,']');
exit;
end;
end;
end;
tx.init(fname,false);
while tx.fetchnext(line) and not done do
begin
pCurrFName := fname;
OUTSetPageLabels(PackTimeStr(FileDate(pCurrFname,'')),'','');
inc(linenumber);
if not CommandLine(line,newfile,newsect) then
begin
pCurrFName := fname;
PrintLine(line);
end;
if (newfile = 'EXIT') or (newfile = 'QUIT') then done := true
else if SourceFlag and (newfile <> '') then
begin
if newsect <> '' then
begin
{ OUT(' sourcing ['+newfile+'] ['+secttag+'] ['+newsect+'] ');}
SectLineFlag := true;
ReadTEXTSection(newfile,secttag,newsect,0,ProcessSourcedLine);
end
else ReadTEXTfile(newfile,ProcessSourcedLine);
end;
newfile := '';
newsect := '';
end;
tx.done;
end;
Procedure AddDollarParms;
var i : integer;
s : string;
begin
for i := 1 to 9 do
begin
s := '@'+integerstr(i,1);
AddParm(1,s,'');
end;
end;
Procedure GetDollarParms;
var i : integer;
s : string;
begin
for i := 1 to 9 do
begin
s := '@'+integerstr(i,1);
AtStr[i] := GetParmStr(s);
end;
end;
Procedure DumpDollarParms;
var i : integer;
begin
writeln('Dollar Parms');
for i := 1 to 9 do
if AtStr[i] <> '' then writeln(' @',i:1,' = [',AtStr[i],']');
writeln('');
end;
Procedure Init;
begin
SectLineFlag := false;
AddParm(1,'SOURCE','YES');
AddParm(1,'ECHO','NO');
AddParm(1,'COMPRESSED','NO');
AddParm(1,'TRIGGER','92'); { \ }
AddParm(1,'SECTTAG','{SECTION');
AddParm(1,'TBOXTYPE','1');
AddParm(1,'HEADERS','YES');
AddParm(1,'FOOTERS','YES');
AddParm(1,'HEADER1','');
AddParm(1,'HEADER2','');
AddParm(1,'HEADER3','');
AddParm(1,'FOOTER1','||@PAGE');
AddParm(1,'FOOTER2','');
center := 0;
doubleflag := false;
AddDollarParms;
StandardOUTInit;
PARMSetFirstLast;
GetDollarParms;
SourceFlag := CheckOK('SOURCE');
TriggerCh := chr(GetParmNum('TRIGGER'));
EchoFlag := CheckOK('ECHO');
DoubleFlag := CheckOK('DOUBLE');
HeadersFlag := CheckOK('HEADERS');
FootersFlag := CheckOK('FOOTERS');
TBOXType := GetParmNum('TBOXTYPE');
secttag := GetParmStr('SECTTAG');
quotechar := ''''; { Single quote - for scan stuff }
OUTSetHeaders(pHeader1,pHeader2,pHeader3,pFooter1,pFooter2);
end;
begin
pProgID := 'TPrint 3.02';
Init;
if pDebug then DumpDollarParms;
if paramcount > 0 then
begin
ReadFile1(paramstr(1));
OUTdone;
end
else ShowDocFile;
end.